-- CIS 552, Mini-project
-- by Mike Gottlieb and Reilly Grant

-- |Representation of the deck.  Since there should only be one deck, operations
--  which modify the deck return the resulting deck as well.
module Deck (T, -- type
             deck, -- constructor
             pick, deal, shuffle, -- functions modifying type
             test -- tests
            ) where

import Util
import Random
import Test.HUnit hiding (test)
import Control.Monad.ST

import qualified Card

data T = Deck [Card.T]
       deriving (Show, Eq)

-- |Constructs a deck with all 52 cards.
deck :: T
deck = Deck [Card.card suit rank | suit <- [Card.Heart ..], rank <- [2..14]]

-- |Shuffles the deck, bridging the deck 7 times has been shown to provide
--  adequate randomness.
shuffle :: T -> IO T
shuffle (Deck d) = do d0 <- shuffle' d
                      d1 <- shuffle' d0
                      d2 <- shuffle' d1
                      d3 <- shuffle' d2
                      d4 <- shuffle' d3
                      d5 <- shuffle' d4
                      d6 <- shuffle' d5
                      return (Deck d6)
    where shuffle' [] = return []
          shuffle' d = do let midpoint = length d `div` 2
                              (a, b) = splitAt midpoint d
                          cards <- bridge a b
                          return cards

-- |Perform one bridge operation, this type of shuffling translates nicely
--  into a functional recursive implementation.
bridge :: [Card.T] -> [Card.T] -> IO [Card.T]
bridge [] [] = return []
bridge a []  = return a
bridge [] b  = return b
bridge a@(a':as) b@(b':bs) = 
    do flip <- randomIO
       if flip 
         then do rest <- bridge as b
                 return (a' : rest)
         else do rest <- bridge a bs
                 return (b' : rest)

-- |Pick one card from the deck, return the resulting deck.
pick :: T -> (Card.T, T)
pick (Deck cs) = case cs of (c:cs) -> (c, Deck cs)
                            []     -> error "Deck is empty"

-- |Pick n cards from the deck, return the resulting deck.
deal :: T -> Int -> ([Card.T], T)
deal d 0 = ([], d)
deal d n = (c : cs, rest2)
           where (c, rest1)  = pick d
                 (cs, rest2) = deal rest1 (n-1)

-- |Number of cards left in the deck.
size :: T -> Int
size (Deck cs) = length cs

------------------------------------------------------------
-- Testing
------------------------------------------------------------

-- |Add a card into the deck (for testing purposes only).
addCard :: T -> Card.T -> T
addCard (Deck cs) c = Deck (c:cs)

-- |Verify there are 13 cards of each suit.
verifySuits :: T -> Bool
verifySuits (Deck cs) = and $ map thirteenFound [Card.Heart .. ]
    where thirteenFound s = countWith ((s==) . Card.suit) cs == 13 

-- |Verify there are 4 cards of each rank.
verifyRanks :: T -> Bool
verifyRanks (Deck cs) = and $ map fourFound [2..14]
    where fourFound r = countWith ((r==) . Card.rank) cs == 4

-- |Verify the deck contains 52 cards, 4 of each rank and 13 of each suit.
verifyDeck :: T -> Bool
verifyDeck d = verifySuits d && verifyRanks d && size d == 52

-- |Check a newly constructed deck is correct.
test_legit = TestCase $ do assertBool "legal deck" (verifyDeck deck)
                           let (c, d') = pick deck      -- one card too few
                               d''     = addCard deck c -- one card too many
                           assertBool "illegal deck" (not $ verifyDeck d')
                           assertBool "illegal deck" (not $ verifyDeck d'')

-- |Check a shuffled deck is still correct.
test_shuffle = TestCase $ do d' <- shuffle deck
                             assertBool "shuffle deck" (verifyDeck d')

-- |Check that picking a card and then replacing it still yields a valid deck.
test_deal = TestCase $ do d <- shuffle deck
                          let (c, d') = pick d
                              d'' = addCard d' c
                          assertBool "deal deck" (verifyDeck d'')

tests = TestList [test_legit, test_shuffle, test_deal]

-- |Run all deck test cases.                             
test = runTestTT tests
